home *** CD-ROM | disk | FTP | other *** search
/ Disc to the Future 2 / Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin / MAC / MPW_TOOL / TOOLS / TOOLS_WI / ICON_8 / ICONX_FO / RLOCAL.C < prev    next >
Text File  |  1990-03-11  |  21KB  |  814 lines
  1. /*
  2.  * Routines needed for different systems.
  3.  */
  4.  
  5. #include <math.h>
  6. #include "::h:config.h"
  7. #include "::h:rt.h"
  8. #include "rproto.h"
  9. #include <ctype.h>
  10.  
  11. /*
  12.  * The following code is operating-system dependent [@rlocal.01].
  13.  *  Routines needed by different systems.
  14.  */
  15.  
  16. #if PORT
  17.    /* place for anything system-specific */
  18. Deliberate Syntax Error
  19. #endif                    /* PORT */
  20.  
  21. #if AMIGA
  22. #if AZTEC_C
  23. /*
  24.  * abs
  25.  */
  26. abs(i)
  27. int i;
  28. {
  29.     return ((i<0)? (-i) : i);
  30. }
  31.  
  32. /*
  33.  * ldexp
  34.  */
  35. double ldexp(value,exp)
  36. double value;
  37. {
  38.   double retval = 1.0;
  39.   if(exp>0) {
  40.     while(exp-->0) retval *= 2.0;
  41.   } else if (exp<0) {
  42.     while(exp++<0) retval = retval / 2.0;
  43.   }
  44.   return value * retval;
  45. }
  46.  
  47. /*
  48.  *  abort()
  49.  */
  50. novalue abort()
  51. {
  52.   fprintf(stderr,"ICON ERROR WITH ICONCORE SET\n");
  53.   fflush(stderr);
  54.   exit(1);
  55. }
  56.  
  57. #ifdef SystemFnc
  58.  
  59. /*
  60.  * Aztec C version 3.6 does not support system(), but here is a substitute.
  61.  * This is a bonafide untested-original-it-just-compiles routine.
  62.  * Manx will probably implement system() before we fix this version...
  63.  */
  64. #include <ctype.h>
  65.  
  66. #define KLUDGE1 256
  67. #define KLUDGE2 64
  68. int system(s)
  69. char *s;
  70. {
  71.    char text[KLUDGE1], *cp=text;
  72.    char **av[KLUDGE2];
  73.    int ac = 0;
  74.    int l  = strlen(s);
  75.  
  76.    if (l >= KLUDGE1)
  77.       return -1;
  78.    strcpy(text,s);
  79.    av[ac++] = text;
  80.    while(*cp && ac<KLUDGE2-1) {
  81.       if (isspace(*cp)) {
  82.          *cp++ = '\0';
  83.      while(isspace(*cp))
  84.         cp++;
  85.          if (*cp)
  86.         av[ac++] = cp;
  87.          }
  88.       else {
  89.          cp++;
  90.          }
  91.       }
  92.     av[ac] = NULL;
  93.     return fexecv(av[0], av);
  94. }
  95. #endif                    /* SystemFnc */
  96. #endif                    /* AZTEC_C */
  97. #endif                    /* AMIGA */
  98.  
  99. #if ATARI_ST
  100. #if LATTICE
  101.  
  102. long _STACK = 10240;
  103. long _MNEED = 200000;    /* reserve space for allocation (may be too large) */
  104.  
  105. #include <osbind.h>
  106.  
  107. /*  Structure necessary for handling system time. */
  108.    struct tm {
  109.        short tm_year;
  110.        short tm_mon;
  111.        short tm_wday;
  112.        short tm_mday;
  113.        short tm_hour;
  114.        short tm_min;
  115.        short tm_sec;
  116.    };
  117.  
  118. struct tm *localtime(clock)   /* fill structure with clock time */
  119. int clock;     /* millisecond timer value, if supplied; not used */
  120. {
  121.   static struct tm tv;
  122.   unsigned int time, date;
  123.  
  124.   time = Tgettime();
  125.   date = Tgetdate();
  126.   tv.tm_year = ((date >> 9) & 0x7f) + 80;
  127.   tv.tm_mon  = ((date >> 5) & 0xf) - 1;
  128.   tv.tm_mday = date & 0x1f;
  129.   tv.tm_hour = (time >> 11) & 0x1f;
  130.   tv.tm_min  = (time >> 5)  & 0x3f;
  131.   tv.tm_sec  = 2 * (time & 0x1f);
  132.  
  133.   tv.tm_wday = weekday(tv.tm_mday,tv.tm_mon+1,tv.tm_year);
  134.   return(&tv);
  135. }
  136.  
  137.  
  138. weekday(day,month,year)   /* find day of week from    */
  139. short day, month, year;   /* day, month, and year     */
  140. {                         /* Sunday..Saturday is 0..6 */
  141.   int index, yrndx, mondx;
  142.  
  143.   if(month <= 2) {   /* Jan or Feb month adjust */
  144.       month += 12;
  145.       year  -=  1;
  146.   }
  147.  
  148.   yrndx = year + (year / 4) - (year / 100) + (year / 400);
  149.   mondx = 2 * month + (3 * (month + 1)) / 5;
  150.   index = day + mondx + yrndx + 2;
  151.   return(index % 7);
  152. }
  153.  
  154.  
  155.  
  156. time(ptime)   /* return value of millisecond timer */
  157. int  *ptime;
  158. {
  159.   int  tmp, ssp;   /* value of supervisor stack pointer */
  160.   static int  *tmr = (int *) 0x04ba;   /* addr of timer */
  161.  
  162.   ssp = gemdos(0x20,0);   /* enter supervisor mode */
  163.   tmp = *tmr * 5;         /* get millisecond timer */
  164.   ssp = gemdos(0x20,ssp); /* enter programmer mode */
  165.  
  166.   if(ptime != NULL)
  167.       *ptime = tmp;
  168.  
  169.   return(tmp);
  170. }
  171.  
  172. int brk(p)
  173. char *p;
  174. {
  175.   char *sbrk();
  176.   long int l, m;
  177.  
  178.   l = (long int)p;
  179.   m = (long int)sbrk(0);
  180.  
  181.   return((lsbrk((long) (l - m)) == 0) ? -1 : 0);
  182. }
  183.  
  184.  
  185. #ifdef LocalQsort
  186. /* Shell sort with some enhancements from Knuth.. */
  187.  
  188. void qsort( base, nel, width, cmp )   /* was llqsort( ... */
  189. char *base;                           /*-also kqsort( ...-*/
  190. int nel;
  191. int width;
  192. int (*cmp)();
  193. {
  194.    register int i, j;
  195.    long int gap;
  196.    int k, tmp ;
  197.    char *p1, *p2;
  198.  
  199.    for( gap=1; gap <= nel; gap = 3*gap + 1 ) ;
  200.  
  201.    for( gap /= 3;  gap > 0  ; gap /= 3 )
  202.        for( i = gap; i < nel; i++ )
  203.            for( j = i-gap; j >= 0 ; j -= gap ) {
  204.                 p1 = base + ( j     * width);
  205.                 p2 = base + ((j+gap) * width);
  206.  
  207.                 if( (*cmp)( p1, p2 ) <= 0 ) break;
  208.  
  209.                 for( k = width; --k >= 0 ;) {
  210.                    tmp   = *p1;
  211.                    *p1++ = *p2;
  212.                    *p2++ = tmp;
  213.                 }
  214.            }
  215. }
  216. #endif                    /* LocalQsort */
  217.  
  218. #endif                    /* LATTICE */
  219. #endif                    /* ATARI_ST */
  220.  
  221. #if HIGHC_386
  222. #endif                    /* HIGHC_386 */
  223.  
  224. #if MACINTOSH
  225. #if MPW
  226. /*
  227. **  Special routines for Macintosh Programmer's Workshop
  228. **  implementation of the Icon Programming Language
  229. */
  230.  
  231. #include <Types.h>
  232. #include <Events.h>
  233. #include <OSUtils.h>
  234. #define MaxBlockX MaxBlock /* MaxBlock Icon definition conflicts */
  235. #undef MaxBlock           /* with Mac Toolbox routine */
  236. #include <Memory.h>
  237. #define MaxBlock MaxBlockX
  238. #undef MaxBlockX
  239. #include <Errors.h>
  240.  
  241. /*
  242. **  Initialization and Termination Routines
  243. */
  244. /*
  245. **  MacExit -- This function is installed by an onexit() call in MacInit
  246. **  -- it is called automatically when the program terminates.
  247. */
  248. void
  249. MacExit()
  250. {
  251.   void ResetStack();
  252.   extern Ptr MemBlock;
  253.  
  254.   ResetStack();
  255.   if (MemBlock != NULL) DisposPtr(MemBlock);
  256. }
  257.  
  258. /*
  259. **  MacInit -- This function is called near the beginning of execution of
  260. **  iconx.  It is called by our own brk/sbrk initialization routine.
  261. */
  262. void
  263. MacInit()
  264. {
  265.   atexit(MacExit);
  266. }
  267.  
  268.  
  269. /*
  270. **  Brk and Sbrk Equivalents
  271. */
  272.  
  273. typedef Ptr caddr_t;
  274.  
  275. static caddr_t MemBlock, Break, Limit;
  276. word xcodesize;
  277.  
  278. init_brk()
  279. {
  280.   static short init = 0;
  281.   Size max, grow, size;
  282.   char *v;
  283.   extern word mstksize, statsize, ssize, abrsize;
  284.  
  285.   if (!init) {
  286.     init = 1;
  287.     MacInit();
  288.     if ((v = getenv("ICONSIZE")) != NULL) {    /* if ICONSIZE defined */
  289.       if ((size = atol(v)) <= 0) {        /* if ICONSIZE negative */
  290.     max = MaxMem(&grow);
  291.     size = max + grow - (size < 0 ? -size : max / 4);
  292.       }
  293.     }
  294.     else {                    /* if ICONSIZE undefined */
  295.       size = xcodesize + mstksize + statsize + ssize + abrsize + 512;
  296.     }
  297.     if ((MemBlock = NewPtr(size)) == NULL) {
  298.       syserr("Unable to perform initial Icon memory allocation");
  299.     }
  300.     Break = MemBlock;
  301.     Limit = MemBlock + size;
  302.   }
  303.   return 1;
  304. }
  305.  
  306. caddr_t
  307. brk(addr)
  308. caddr_t addr;
  309. {
  310.   Size newsize;
  311.  
  312.   if (!init_brk()) return (caddr_t)-1;
  313.   if (addr < MemBlock) return (caddr_t)-1;
  314.   if (addr < Limit) Break = addr;
  315.   else {
  316.     newsize = addr - MemBlock;
  317.     SetPtrSize(MemBlock, newsize);
  318.     if (MemError() != noErr) return (caddr_t)-1;
  319.     Break = Limit = addr;
  320.   }
  321.   return (caddr_t)0;
  322. }
  323.  
  324. caddr_t
  325. sbrk(incr)
  326. int incr;
  327. {
  328.   caddr_t start;
  329.  
  330.   if (!init_brk()) return (caddr_t)-1;
  331.   start = Break;
  332.   if (incr != 0) {
  333.     if (brk(start + incr) == (caddr_t)-1) return (caddr_t)-1;
  334.   }
  335.   return start;
  336. }
  337.  
  338. #endif                    /* MPW */
  339. #endif                    /* MACINTOSH */
  340.  
  341. #if MSDOS
  342.  
  343. #if TURBO
  344. extern unsigned _stklen = 8 * 1024;
  345. #endif                    /* TURBO */
  346.  
  347. #if LATTICE
  348.  
  349. #include <error.h>
  350.  
  351. int _stack = (8 * 1024);
  352. long int _mneed = (20 * 1024);
  353.  
  354. extern long int *sp;
  355. long int **xsp = &sp;  /* Used for rswitch.asm .. since 'sp' is a reserved */
  356.                /* symbol for the assembler.. */
  357.  
  358. extern char *statend;  /* Indicator for when to use malloc for _GETBF */
  359.  
  360. int brk(p)
  361. char *p;
  362. {
  363.    char *sbrk();
  364.    long int l, m;
  365.  
  366.    l = (long int)p;
  367.    m = (long int)sbrk((word)0);
  368.  
  369.    if( lsbrk((long) (l - m) ) == 0) return -1;
  370.    else return 0;
  371. }
  372.  
  373. novalue abort()    /* Abort set to 'dump' icon data area.. */
  374. {
  375. #ifdef DeBugIconx
  376.    blkdump();
  377. #endif                    /* DeBugIconx */
  378.    fflush(stderr);
  379.    fcloseall();
  380.    _exit(1);
  381. }
  382. #endif                    /* LATTICE */
  383. #endif                    /* MSDOS */
  384.  
  385. #if MVS || VM
  386. const int _staksize = (64*1024);
  387. #endif                    /* MVS || VM */
  388.  
  389. #if OS2
  390. #endif                    /* OS2 */
  391.  
  392. #if UNIX
  393. #ifdef ATTM32
  394.  
  395. /*
  396.  * This file contains the routine necessary to allocate legal AT&T
  397.  * 3B2/15/4000 stack space for co-expression stacks.
  398.  *
  399.  * Legal stack region begins at 0xC0020000, and UNIX will grow stack space
  400.  * up to 50 Megabytes. 0xC0030000 should provide plenty of room for
  401.  * main C stack growth.  Each time coexpr_salloc() is called, it
  402.  * adds mstksize (max main stack size) and returns a new address,
  403.  * meaning each coexpression stack is potentially as large as the main stack.
  404.  */
  405.  
  406. /*
  407.  * coexp_salloc() - return pointer in legal stack space for start
  408.  *                  of a coexpression stack.
  409.  */
  410.  
  411. pointer coexp_salloc()
  412.    {
  413.    static pointer sp = 0xC0030000 ;     /* pointer to stack region */
  414.  
  415.    sp +=  mstksize;
  416.    return sp;
  417. }
  418. #endif                    /* ATTM32 */
  419. #if CONVEX
  420.  
  421. /* replacement pow() that allows negative ** integer */
  422.  
  423. #undef pow
  424.  
  425. double pow0 (base, exp)
  426.     double base, exp;
  427. {   if (base >= 0) return pow (base, exp);
  428.     else {
  429.     long n = exp;
  430.     if (n != exp) runerr (-206, 0);
  431.     else if (n & 1) return -pow (-base, exp);
  432.     else return pow (-base, exp);}}
  433. #endif                    /* CONVEX */
  434.  
  435. #endif                    /* UNIX */
  436.  
  437. #if VMS
  438. #include dvidef
  439. #include iodef
  440.  
  441. typedef struct _descr {
  442.    int length;
  443.    char *ptr;
  444. } descriptor;
  445.  
  446. typedef struct _pipe {
  447.    long pid;            /* process id of child */
  448.    long status;            /* exit status of child */
  449.    long flags;            /* LIB$SPAWN flags */
  450.    int channel;            /* MBX channel number */
  451.    int efn;            /* Event flag to wait for */
  452.    char mode;            /* the open mode */
  453.    FILE *fptr;            /* file pointer (for fun) */
  454.    unsigned running : 1;    /* 1 if child is running */
  455. } Pipe;
  456.  
  457. Pipe _pipes[_NFILE];        /* one for every open file */
  458.  
  459. #define NOWAIT        1
  460. #define NOCLISYM    2
  461. #define NOLOGNAM    4
  462. #define NOKEYPAD    8
  463. #define NOTIFY        16
  464. #define NOCONTROL    32
  465. #define SFLAGS    (NOWAIT|NOKEYPAD|NOCONTROL)
  466.  
  467. /*
  468.  * popen - open a pipe command
  469.  * Last modified 2-Apr-86/chj
  470.  *
  471.  *    popen("command", mode)
  472.  */
  473.  
  474. FILE *popen(cmd, mode)
  475. char *cmd;
  476. char *mode;
  477. {
  478.    FILE *pfile;            /* the Pfile */
  479.    Pipe *pd;            /* _pipe database */
  480.    descriptor mbxname;        /* name of mailbox */
  481.    descriptor command;        /* command string descriptor */
  482.    descriptor nl;        /* null device descriptor */
  483.    char mname[65];        /* mailbox name string */
  484.    int chan;            /* mailbox channel number */
  485.    int status;            /* system service status */
  486.    int efn;
  487.    struct {
  488.       short len;
  489.       short code;
  490.       char *address;
  491.       char *retlen;
  492.       int last;
  493.    } itmlst;
  494.  
  495.    if (!cmd || !mode)
  496.       return (0);
  497.    LIB$GET_EF(&efn);
  498.    if (efn == -1)
  499.       return (0);
  500.    if (_tolower(mode[0]) != 'r' && _tolower(mode[0]) != 'w')
  501.       return (0);
  502.    /* create and open the mailbox */
  503.    status = SYS$CREMBX(0, &chan, 0, 0, 0, 0, 0);
  504.    if (!(status & 1)) {
  505.       LIB$FREE_EF(&efn);
  506.       return (0);
  507.    }
  508.    itmlst.last = mbxname.length = 0;
  509.    itmlst.address = mbxname.ptr = mname;
  510.    itmlst.retlen = &mbxname.length;
  511.    itmlst.code = DVI$_DEVNAM;
  512.    itmlst.len = 64;
  513.    status = SYS$GETDVIW(0, chan, 0, &itmlst, 0, 0, 0, 0);
  514.    if (!(status & 1)) {
  515.       LIB$FREE_EF(&efn);
  516.       return (0);
  517.    }
  518.    mname[mbxname.length] = '\0';
  519.    pfile = fopen(mname, mode);
  520.    if (!pfile) {
  521.       LIB$FREE_EF(&efn);
  522.       SYS$DASSGN(chan);
  523.       return (0);
  524.    }
  525.    /* Save file information now */
  526.    pd = &_pipes[fileno(pfile)];    /* get Pipe pointer */
  527.    pd->mode = _tolower(mode[0]);
  528.    pd->fptr = pfile;
  529.    pd->pid = pd->status = pd->running = 0;
  530.    pd->flags = SFLAGS;
  531.    pd->channel = chan;
  532.    pd->efn = efn;
  533.    /* fork the command */
  534.    nl.length = strlen("_NL:");
  535.    nl.ptr = "_NL:";
  536.    command.length = strlen(cmd);
  537.    command.ptr = cmd;
  538.    status = LIB$SPAWN(&command,
  539.       (pd->mode == 'r') ? 0 : &mbxname,    /* input file */
  540.       (pd->mode == 'r') ? &mbxname : 0,    /* output file */
  541.       &pd->flags, 0, &pd->pid, &pd->status, &pd->efn, 0, 0, 0, 0);
  542.    if (!(status & 1)) {
  543.       LIB$FREE_EF(&efn);
  544.       SYS$DASSGN(chan);
  545.       return (0);
  546.    } else {
  547.       pd->running = 1;
  548.    }
  549.    return (pfile);
  550. }
  551.  
  552. /*
  553.  * pclose - close a pipe
  554.  * Last modified 2-Apr-86/chj
  555.  *
  556.  */
  557. pclose(pfile)
  558. FILE *pfile;
  559. {
  560.    Pipe *pd;
  561.    int status;
  562.    int fstatus;
  563.  
  564.    pd = fileno(pfile) ? &_pipes[fileno(pfile)] : 0;
  565.    if (pd == NULL)
  566.       return (-1);
  567.    fflush(pd->fptr);            /* flush buffers */
  568.    fstatus = fclose(pfile);
  569.    if (pd->mode == 'w') {
  570.       status = SYS$QIOW(0, pd->channel, IO$_WRITEOF, 0, 0, 0, 0, 0, 0, 0, 0, 0);
  571.       SYS$WFLOR(pd->efn, 1 << (pd->efn % 32));
  572.    }
  573.    SYS$DASSGN(pd->channel);
  574.    LIB$FREE_EF(&pd->efn);
  575.    pd->running = 0;
  576.    return (fstatus);
  577. }
  578.  
  579. /*
  580.  * redirect(&argc,argv,nfargs) - redirect standard I/O
  581.  *    int *argc        number of command arguments (from call to main)
  582.  *    char *argv[]    command argument list (from call to main)
  583.  *    int nfargs    number of filename arguments to process
  584.  *
  585.  * argc and argv will be adjusted by redirect.
  586.  *
  587.  * redirect processes a program's command argument list and handles redirection
  588.  * of stdin, and stdout.  Any arguments which redirect I/O are removed from the
  589.  * argument list, and argc is adjusted accordingly.  redirect would typically be
  590.  * called as the first statement in the main program.
  591.  *
  592.  * Files are redirected based on syntax or position of command arguments.
  593.  * Arguments of the following forms always redirect a file:
  594.  *
  595.  *    <file    redirects standard input to read the given file
  596.  *    >file    redirects standard output to write to the given file
  597.  *    >>file    redirects standard output to append to the given file
  598.  *
  599.  * It is often useful to allow alternate input and output files as the
  600.  * first two command arguments without requiring the <file and >file
  601.  * syntax.  If the nfargs argument to redirect is 2 or more then the
  602.  * first two command arguments, if supplied, will be interpreted in this
  603.  * manner:  the first argument replaces stdin and the second stdout.
  604.  * A filename of "-" may be specified to occupy a position without
  605.  * performing any redirection.
  606.  *
  607.  * If nfargs is 1, only the first argument will be considered and will
  608.  * replace standard input if given.  Any arguments processed by setting
  609.  * nfargs > 0 will be removed from the argument list, and again argc will
  610.  * be adjusted.  Positional redirection follows syntax-specified
  611.  * redirection and therefore overrides it.
  612.  *
  613.  */
  614.  
  615.  
  616. redirect(argc,argv,nfargs)
  617. int *argc, nfargs;
  618. char *argv[];
  619. {
  620.    int i;
  621.  
  622.    i = 1;
  623.    while (i < *argc)  {        /* for every command argument... */
  624.       switch (argv[i][0])  {        /* check first character */
  625.          case '<':            /* <file redirects stdin */
  626.             filearg(argc,argv,i,1,stdin,"r");
  627.             break;
  628.          case '>':            /* >file or >>file redirects stdout */
  629.             if (argv[i][1] == '>')
  630.                filearg(argc,argv,i,2,stdout,"a");
  631.             else
  632.                filearg(argc,argv,i,1,stdout,"w");
  633.             break;
  634.          default:            /* not recognized, go on to next arg */
  635.             i++;
  636.       }
  637.    }
  638.    if (nfargs >= 1 && *argc > 1)    /* if positional redirection & 1 arg */
  639.       filearg(argc,argv,1,0,stdin,"r");    /* then redirect stdin */
  640.    if (nfargs >= 2 && *argc > 1)    /* likewise for 2nd arg if wanted */
  641.       filearg(argc,argv,1,0,stdout,"w");/* redirect stdout */
  642. }
  643.  
  644.  
  645.  
  646. /* filearg(&argc,argv,n,i,fp,mode) - redirect and remove file argument
  647.  *    int *argc        number of command arguments (from call to main)
  648.  *    char *argv[]    command argument list (from call to main)
  649.  *    int n        argv entry to use as file name and then delete
  650.  *    int i        first character of file name to use (skip '<' etc.)
  651.  *    FILE *fp        file pointer for file to reopen (typically stdin etc.)
  652.  *    char mode[]    file access mode (see freopen spec)
  653.  */
  654.  
  655. filearg(argc,argv,n,i,fp,mode)
  656. int *argc, n, i;
  657. char *argv[], mode[];
  658. FILE *fp;
  659. {
  660.    if (strcmp(argv[n]+i,"-"))        /* alter file if arg not "-" */
  661.       fp = freopen(argv[n]+i,mode,fp);
  662.    if (fp == NULL)  {            /* abort on error */
  663.       fprintf(stderr,"%%can't open %s",argv[n]+i);
  664.       exit(ErrorExit);
  665.    }
  666.    for ( ;  n < *argc;  n++)        /* move down following arguments */
  667.       argv[n] = argv[n+1];
  668.    *argc = *argc - 1;            /* decrement argument count */
  669. }
  670.  
  671. /* Special versions of sbrk() and brk() for use by Icon under VMS.
  672.  * #defines in define.h actually rename these to vms_brk and vms_sbrk.
  673.  *
  674.  * For historical reasons, Icon assumes it can repeatedly call brk/sbrk
  675.  * and always get contiguous chunks.  This was made to work under Unix by
  676.  * overloading the definitions of malloc and friends, the only other callers
  677.  * of sbrk, and making them return Icon-managed memory.
  678.  
  679.  * Under VMS, sbrk is not the lowest-level system interface.  It gets memory
  680.  * from underlying VMS routines such as SYS$EXPREG.  These routines are also
  681.  * called by others, for example when a file is opened;  so successive sbrk
  682.  * calls may return nonadjacent chunks.  This makes overloading malloc and
  683.  * friends futile.
  684.  *
  685.  * The routines below replace sbrk and brk for Icon (only) under VMS.  They
  686.  * provide the continuously growing memory Icon needs without relying on
  687.  * special privileges or unusually large quotas.  Like the Unix solution and
  688.  * earlier VMS attempts, this is an empirical solution and may need further
  689.  * revision as the system changes.  But we hope not.
  690.  *
  691.  * The Icon interpreter is loaded beginning at address 0 and grows upward as
  692.  * it requests more memory through sbrk.  The C stack grows downward from
  693.  * 0x7FFFFFFF. We're going to draw a line to divide the address space, then
  694.  * force the C and VMS runtime systems to put anything they need above it;
  695.  * then sbrk can grow the program region unimpeded up to the line.
  696.  *
  697.  * The line is drawn MAXMEM bytes beyond the start of the sbrk region.  MAXMEM
  698.  * is an environment variable (logical name to VMS) with a default as given in
  699.  * define.h.  Large values cost CPU and real time expended at process exit; we
  700.  * don't know why.  On an 8600 the cost was very roughly .04 CP sec / megabyte.
  701.  *
  702.  * When first called, sbrk expands the program region by one page to get a
  703.  * starting address.  A limit address is calculated by adding MAXMEM.  A single
  704.  * page created just below the limit address "draws the line" and causes the
  705.  * VMS runtime system to allocate anything it needs above that point.  sbrk
  706.  * creates pages between base and limit as needed.
  707.  *
  708.  * Possible errors and their manifestations:
  709.  *
  710.  *    MAXMEM too large to initialize sbrk:
  711.  *       error in startup code: value of MAXMEM too large
  712.  *
  713.  *    MAXMEM too small to initialize sbrk:
  714.  *       error in startup code: value of MAXMEM too small
  715.  *
  716.  *    MAXMEM too small for subsequent brk/sbrk growth
  717.  *       Run-time error 351:  insufficient MAXMEM limit
  718.  *
  719.  *    MAXMEM okay but insufficient user quota for needed memory:
  720.  *       Run-time error 303:  unable to expand memory region
  721.  *
  722.  *    unexpected ("can't happen") failures of system calls:
  723.  *       these produce their standard VMS error message
  724.  *
  725.  *    unexpected intrusion into the sbrk region by the runtime system:
  726.  *       unknown, but undoubtedly ugly
  727.  */
  728.  
  729.  
  730. #define PageSize 512        /* size of a VMS page */
  731. #define MaxP0 0x40000000    /* first address beyond the P0 region */
  732.  
  733. #include <stsdef.h>
  734.  
  735. word memsize = MaxMem;        /* set from environment variable MAXMEM */
  736.  
  737.  
  738. /*  sbrk(incr) - adjust the break value by incr, rounding up to a page.
  739.  *  returns the new break value, or -1 if unsuccessful.
  740.  */
  741.  
  742. char *
  743. sbrk(incr)
  744. int incr;
  745. {
  746.    static char *base;        /* base of the sbrk region */
  747.    static char *curr;        /* current break value (end+1) */
  748.    static char *limit;        /* region limit ("the line") */
  749.    char *range[2], *p;        /* scratch for system calls */
  750.    int s;            /* status return from calls */
  751.  
  752.    /*  initialization code */
  753.    if (!base)  {
  754.       s = sys$expreg(1,range,0,0);    /* expand P0 to get base address */
  755.       if (!(s & STS$M_SUCCESS))
  756.          exit(s);            /* couldn't get one page?! */
  757.       base = curr = range[0];        /* initialize empty sbrk region */
  758.       memsize = (memsize + PageSize - 1) & -PageSize;
  759.                     /* round memsize to page boundary */
  760.       limit = base + memsize;        /* calculate sbrk region limit*/
  761.       if (limit > MaxP0)
  762.      limit = MaxP0;            /* limit to legal values */
  763.       if (limit <= base)
  764.          error("value of MAXMEM too small");  /* can't even start */
  765.       range[0] = range[1] = limit-1;
  766.       s = sys$cretva(range,range,0);    /* get a page there to draw the line */
  767.       if (!(s & STS$M_SUCCESS))
  768.          error("value of MAXMEM too large");  /* can't even start */
  769.    }
  770.  
  771.    if (incr > 0)  {
  772.  
  773.       /* grow the region */
  774.       if (curr + incr > limit)        /* check address space available */
  775.          fatalerr(-351,NULL);        /* oops, MAXMEM too small */
  776.       range[0] = curr;
  777.       range[1] = curr + incr - 1;
  778.       s = sys$cretva(range,range,0);    /* ask for the pages */
  779.       if (!(s & STS$M_SUCCESS))
  780.          return (char *) -1;        /* failed, quota exceeded */
  781.       curr = range[1] + 1;        /* set new break value as returned */
  782.  
  783.    } else if (incr < 0) {
  784.  
  785.       /* shrink the region (not expected to be used).  does not actually
  786.        * return the memory, but does make it available for reuse.  */
  787.       curr -= -incr & -PageSize;
  788.    }
  789.  
  790.    /* return the current break value */
  791.    return curr;
  792. }
  793.  
  794.  
  795.  
  796.  
  797. /*  brk(addr) - set the break address to the given value, rounded up to a page.
  798.  *  returns 0 if successful, -1 if not.
  799.  */
  800.  
  801. char *
  802. brk(addr)
  803. char *addr;
  804. {
  805.    return ((sbrk(addr-sbrk(0))) == (char *) -1 ? (char *) -1 : 0);
  806. }
  807. #endif                    /* VMS */
  808.  
  809. /*
  810.  * End of operating-system specific code.
  811.  */
  812.  
  813. static char x;            /* avoid empty module */
  814.